home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / ilisp / ilisp-cmp.el.z / ilisp-cmp.el
Encoding:
Text File  |  1998-05-21  |  11.7 KB  |  336 lines
  1. ;;; -*- Mode: Emacs-Lisp -*-
  2.  
  3. ;;; ilisp-cmp.el --
  4.  
  5. ;;; This file is part of ILISP.
  6. ;;; Version: 5.8
  7. ;;;
  8. ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell
  9. ;;;               1993, 1994 Ivan Vasquez
  10. ;;;               1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker
  11. ;;;               1996 Marco Antoniotti and Rick Campbell
  12. ;;;
  13. ;;; Other authors' names for which this Copyright notice also holds
  14. ;;; may appear later in this file.
  15. ;;;
  16. ;;; Send mail to 'ilisp-request@naggum.no' to be included in the
  17. ;;; ILISP mailing list. 'ilisp@naggum.no' is the general ILISP
  18. ;;; mailing list were bugs and improvements are discussed.
  19. ;;;
  20. ;;; ILISP is freely redistributable under the terms found in the file
  21. ;;; COPYING.
  22.  
  23.  
  24.  
  25. ;;;
  26. ;;; ILISP completion
  27. ;;;
  28. ;;;
  29. ;;;%Completion
  30. ;;; The basic idea behind the completion stuff is to use as much of
  31. ;;; the standard Emacs stuff as possible.  The extensions here go out
  32. ;;; to the inferior LISP to complete symbols if necessary.  
  33. ;;; 
  34. (defun ilisp-display-choices (symbol choices)
  35.   "Display the possible choices for SYMBOL in alist CHOICES."
  36.   (with-output-to-temp-buffer "*Completions*"
  37.     (display-completion-list
  38.      (sort 
  39.       (all-completions (lisp-symbol-name symbol) choices)
  40.       'string-lessp))))
  41.  
  42. ;;;%%ilisp-can-complete
  43. (defun ilisp-can-complete (symbol function-p)
  44.   "Return T if ilisp completion can complete SYMBOL from the current table."
  45.   (and ilisp-original 
  46.        (string= (lisp-symbol-package ilisp-original) 
  47.         (lisp-symbol-package symbol))
  48.        (string= (lisp-symbol-delimiter ilisp-original)
  49.         (lisp-symbol-delimiter symbol))
  50.        (lisp-prefix-p (lisp-symbol-name ilisp-original)
  51.               (lisp-symbol-name symbol))
  52.        (eq function-p ilisp-original-function-p)))
  53.  
  54. ;;;%%ilisp-complete
  55. (defun ilisp-complete (symbol &optional function-p)
  56.   "Return a list of the possible completions for symbol from the
  57. inferior LISP.  If FUNCTION-P is T, only symbols with function
  58. bindings will be considered.  If no package is specified the buffer
  59. package will be used."
  60.   (let* ((choices 
  61.       (ilisp-send 
  62.        (format  (ilisp-value 'ilisp-complete-command) 
  63.             (lisp-symbol-name symbol) (lisp-symbol-package symbol)
  64.             function-p
  65.             (string= (lisp-symbol-delimiter symbol) ":")
  66.             ilisp-prefix-match)
  67.        (if (not ilisp-complete)
  68.            (concat "Complete " 
  69.                (if function-p "function ")
  70.                (lisp-buffer-symbol symbol)))
  71.        'complete)))
  72.     (if (ilisp-value 'comint-errorp t)
  73.     (progn (lisp-display-output choices)
  74.            (error "Error completing %s" (lisp-buffer-symbol symbol)))
  75.     (setq choices (read choices)
  76.           choices (if (eq choices 'NIL) nil choices)))
  77.     (setq ilisp-original symbol
  78.       ilisp-original-function-p function-p
  79.       ilisp-original-table choices)))
  80.  
  81. ;;;%%ilisp-completion-table
  82. (defun ilisp-completion-table (symbol function-p)
  83.   "Return the completion table for SYMBOL trying to use the current
  84. one.  If FUNCTION-P is T, only symbols with function cells will be
  85. returned."
  86.   (if (ilisp-can-complete symbol function-p) 
  87.       ilisp-original-table
  88.       (ilisp-complete symbol function-p)))
  89.  
  90. ;;;%%Minibuffer completion
  91. (defun ilisp-restore-prefix ()
  92.   "Restore the prefix from ilisp-mini-prefix at the start of the
  93. minibuffer."
  94.   (if ilisp-mini-prefix
  95.       (save-excursion
  96.     (goto-char (point-min))
  97.     (insert ilisp-mini-prefix)
  98.     (setq ilisp-mini-prefix nil))))
  99.  
  100. ;;;
  101. (defun ilisp-current-choice ()
  102.   "Set up the minibuffer completion table for the current symbol.
  103. If there is a paren at the start of the minibuffer, or there is not an
  104. ilisp-table, this will be from the inferior LISP.  Otherwise, it will
  105. be the ilisp-table."
  106.   (if (or (null ilisp-table) (eq (char-after 1) ?\())
  107.       (progn
  108.     (let* ((symbol-info (lisp-previous-symbol))
  109.            (symbol (car symbol-info)))
  110.       (setq minibuffer-completion-table 
  111.         (ilisp-completion-table symbol ilisp-completion-function-p)))
  112.     (save-excursion 
  113.       (skip-chars-backward "^: \(")
  114.       (setq ilisp-mini-prefix (buffer-substring (point-min) (point)))
  115.       (delete-region (point-min) (point)))
  116.     ;; Nothing can match this table
  117.     (if (not minibuffer-completion-table)
  118.         (setq minibuffer-completion-table '((" ")))))
  119.       (setq minibuffer-completion-table ilisp-table
  120.         minibuffer-completion-predicate nil)))
  121.  
  122. ;;;%%Commands
  123. (defvar ilisp-completion-help
  124.   (lookup-key minibuffer-local-must-match-map "?"))
  125. (defun ilisp-completion-help ()
  126.   "Inferior LISP minibuffer completion help."
  127.   (interactive)
  128.   (ilisp-current-choice) 
  129.   (funcall ilisp-completion-help)
  130.   (ilisp-restore-prefix))
  131.  
  132. ;;;
  133. (defvar ilisp-completion
  134.   (lookup-key minibuffer-local-must-match-map "\t"))
  135. (defun ilisp-completion ()
  136.   "Inferior LISP minibuffer complete."
  137.   (interactive)
  138.   (ilisp-current-choice)
  139.   (funcall ilisp-completion)
  140.   (ilisp-restore-prefix))
  141.  
  142. ;;;
  143. (defvar ilisp-completion-word
  144.   (lookup-key minibuffer-local-must-match-map " "))
  145. (defun ilisp-completion-word ()
  146.   "Inferior LISP minibuffer complete word."
  147.   (interactive)
  148.   (if (eq (char-after 1) ?\()
  149.       (insert " ")
  150.       (ilisp-current-choice)
  151.       (funcall ilisp-completion-word)
  152.       (ilisp-restore-prefix)))
  153.  
  154. ;;;
  155. (defun ilisp-completion-paren ()
  156.   "Only allow a paren if ilisp-paren is T."
  157.   (interactive)
  158.   (if ilisp-paren 
  159.       (if (or (eq last-input-char ?\() (eq (char-after 1) ?\())
  160.       (insert last-input-char)
  161.       (beep))
  162.       (beep)))
  163.       
  164. ;;; 
  165. (defvar ilisp-completion-exit 
  166.   (lookup-key minibuffer-local-must-match-map "\n"))
  167. (defun ilisp-completion-exit ()
  168.   "Inferior LISP completion complete and exit."
  169.   (interactive)
  170.   (if (eq (char-after 1) ?\()
  171.       (progn (find-unbalanced-lisp nil)
  172.          (exit-minibuffer))
  173.       (if ilisp-no-complete
  174.       (exit-minibuffer)
  175.       (if (= (point-min) (point-max))
  176.           (exit-minibuffer)
  177.           (ilisp-current-choice)
  178.           (unwind-protect (funcall ilisp-completion-exit)
  179.         (ilisp-restore-prefix))))))
  180.  
  181. ;;;%%ilisp-completer
  182. (defun ilisp-completer (symbol function-p)
  183.   "Complete SYMBOL from the inferior LISP using only function symbols
  184. if FUNCTION-P is T.  Return (SYMBOL LCS-SYMBOL CHOICES UNIQUEP)."
  185.   (let* ((name (lisp-symbol-name symbol))
  186.      (table (ilisp-completion-table symbol function-p))
  187.      (choice (and table (try-completion name table))))
  188.     (cond ((eq choice t)        ;Name is it
  189.        (list symbol symbol nil t))
  190.       ((string= name choice)    ;Name is LCS
  191.        (list symbol symbol (all-completions name table) nil))
  192.       (choice            ;New LCS
  193.        (let ((symbol
  194.           (lisp-symbol (lisp-symbol-package symbol) 
  195.                    (lisp-symbol-delimiter symbol)
  196.                    choice)))
  197.          (list symbol symbol (all-completions choice table) nil)))
  198.       ((and (not ilisp-prefix-match) table)    ;Try partial matches
  199.        (let ((matches
  200.           (completer name table nil (regexp-quote completer-words))))
  201.          (cons (lisp-symbol (lisp-symbol-package symbol)
  202.                 (lisp-symbol-delimiter symbol)
  203.                 (car matches))
  204.            (cons  (lisp-symbol (lisp-symbol-package symbol)
  205.                 (lisp-symbol-delimiter symbol)
  206.                 (car (cdr matches)))
  207.               (cdr (cdr matches)))))))))
  208.  
  209.  
  210. ;;;%%ilisp-read
  211. (defun ilisp-completion-map ()
  212.   "Set up the ilisp-completion-map from lisp-mode-map for the ilisp
  213. readers and return it."
  214.   (if (not ilisp-completion-map)
  215.       (progn
  216.     (if (fboundp 'set-keymap-parent)
  217.         (progn
  218.           (setq ilisp-completion-map (make-sparse-keymap))
  219.           (set-keymap-parent ilisp-completion-map lisp-mode-map))
  220.       (setq ilisp-completion-map (copy-keymap lisp-mode-map)))
  221.     (define-key ilisp-completion-map " "  'ilisp-completion-word)
  222.     (define-key ilisp-completion-map "\t" 'ilisp-completion)
  223.     (define-key ilisp-completion-map "?" 'ilisp-completion-help)
  224.     (define-key ilisp-completion-map "\M-\t" 'ilisp-completion)
  225.     (define-key ilisp-completion-map "\n" 'ilisp-completion-exit)
  226.     (define-key ilisp-completion-map "\r" 'ilisp-completion-exit)
  227.     (define-key ilisp-completion-map "\C-g" 'abort-recursive-edit)
  228.     (define-key ilisp-completion-map "(" 'ilisp-completion-paren)
  229.     (define-key ilisp-completion-map ")" 'ilisp-completion-paren)
  230.     (define-key ilisp-completion-map "'" nil)
  231.     (define-key ilisp-completion-map "#" nil)
  232.     (define-key ilisp-completion-map "\"" nil)))
  233.   ilisp-completion-map)
  234.  
  235. ;;;
  236. (defun ilisp-read (prompt &optional initial-contents)
  237.   "PROMPT in the minibuffer with optional INITIAL-CONTENTS and return
  238. the result.  Completion of symbols though the inferior LISP is
  239. allowed."
  240.   (let ((ilisp-complete t)
  241.     (ilisp-paren t)
  242.     (ilisp-no-complete t)
  243.     (ilisp-completion-package (lisp-buffer-package)))
  244.     (read-from-minibuffer prompt initial-contents
  245.               (ilisp-completion-map))))
  246.  
  247. ;;;%%lisp-read-program
  248. (defvar lisp-program-map nil
  249.   "Minibuffer map for reading a program and arguments.")
  250.  
  251. ;;;
  252. (defun lisp-read-program (prompt &optional initial)
  253.   "Read a program with PROMPT and INITIAL.  TAB or Esc-TAB will complete
  254. filenames."
  255.   (if (null lisp-program-map)
  256.       (progn 
  257.     (if (fboundp 'set-keymap-parent)
  258.         (progn
  259.           (setq lisp-program-map (make-sparse-keymap))
  260.           (set-keymap-parent lisp-program-map minibuffer-local-map))
  261.       (setq lisp-program-map (copy-keymap minibuffer-local-map)))
  262.     (define-key lisp-program-map "\M-\t" 'comint-dynamic-complete)
  263.     (define-key lisp-program-map "\t" 'comint-dynamic-complete)
  264.     (define-key lisp-program-map "?" 'comint-dynamic-list-completions)))
  265.   (read-from-minibuffer prompt initial lisp-program-map))
  266.  
  267. ;;;%%ilisp-read-symbol
  268. (defun ilisp-read-symbol (prompt &optional default function-p no-complete)
  269.   "PROMPT in the minibuffer with optional DEFAULT and return a symbol
  270. from the inferior LISP.  If FUNCTION-P is T, only symbols with
  271. function values will be returned.  If NO-COMPLETE is T, then
  272. uncompleted symbols will be allowed."
  273.   (let* ((ilisp-complete t)
  274.      (ilisp-no-complete no-complete)
  275.      (ilisp-completion-package (lisp-buffer-package))
  276.      (ilisp-completion-function-p function-p)
  277.      (string (read-from-minibuffer prompt nil (ilisp-completion-map))))
  278.     (if (equal string "")
  279.     default
  280.     (lisp-string-to-symbol string))))
  281.  
  282. ;;;%%ilisp-completing-read
  283. (defun ilisp-completing-read (prompt table &optional default)
  284.   "Read with PROMPT from an alist of TABLE.  No input returns DEFAULT.
  285. Symbols are from table, other specs are in parentheses."
  286.   (let* ((ilisp-complete t)
  287.      (ilisp-table table)
  288.      (ilisp-completion-package (lisp-buffer-package))
  289.      (ilisp-paren
  290.       (let ((entry table) (done nil))
  291.         (while (and entry (not done))
  292.           (setq done (= (elt (car (car entry)) 0) ?\()
  293.             entry (cdr entry)))
  294.         done))
  295.      (string (read-from-minibuffer prompt nil (ilisp-completion-map))))
  296.     (if (string= string "") default string)))
  297.  
  298.  
  299.  
  300. ;;;%%complete-lisp
  301. (autoload 'complete "completion" "Complete previous symbol." t)
  302. (defun complete-lisp (mode)
  303.   "Complete the current symbol using information from the current
  304. ILISP buffer.  If in a string, complete as a filename.  If called with
  305. a positive prefix force all symbols to be considered.  If called with
  306. a negative prefix, undo the last completion.  Partial completion is
  307. allowed unless ilisp-prefix-match is T.  If a symbol starts after a
  308. left paren or #', then only function symbols will be considered.
  309. Package specifications are also allowed and the distinction between
  310. internal and exported symbols is considered."
  311.   (interactive "P")
  312.   (if (< (prefix-numeric-value mode) 0)
  313.       (completer-undo)
  314.       (let* ((filep
  315.           (save-excursion
  316.         (skip-chars-backward "^ \t\n")
  317.         (= (char-after (point)) ?\"))))
  318.     (if filep
  319.         (comint-dynamic-complete)
  320.         (let* ((symbol-info (lisp-previous-symbol))
  321.            (symbol (car symbol-info))
  322.            (name (lisp-symbol-name symbol))
  323.            (choice (ilisp-completer 
  324.                 symbol 
  325.                 (if (not mode) (car (cdr symbol-info)))))
  326.            (match (lisp-buffer-symbol (car choice)))
  327.            (lcs (lisp-buffer-symbol (car (cdr choice))))
  328.            (choices (car (cdr (cdr choice))))
  329.            (unique (car (cdr (cdr (cdr choice))))))
  330.           (skip-chars-backward " \t\n")
  331.           (completer-goto match lcs choices unique 
  332.                   (ilisp-value 'ilisp-symbol-delimiters)
  333.                   completer-words)))
  334.     (message "Completed"))))
  335.  
  336.